home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / CBoot / class-hacks.em < prev    next >
Lisp/Scheme  |  1993-02-02  |  9KB  |  258 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: class-hacks.em
  4. ;; Date: Wed May 13 11:45:11 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule class-hacks
  11.   (standard0
  12.    list-fns
  13.    scan-args
  14.    )
  15.   ()
  16.   
  17.   ;; macros to get us started.
  18.   ;; idea is that we wind up with 3 things to do:
  19.   ;; 0: allocation
  20.   ;; 1: class hierarchy
  21.   ;; 2: slot-descriptions
  22.   ;; 3: define method-functions
  23.   ;; 4: install methods
  24.   
  25.   (defconstant class-slots (mk-finder))
  26.   (defconstant class-supers (mk-finder))
  27.  
  28.   (deflocal *class-allocation-forms* '(progn))
  29.   (deflocal *class-set-hierarchy-forms* '(progn))
  30.   (deflocal *slot-accessor-forms* '(progn))
  31.   (deflocal *slot-description-forms* '(progn))
  32.   (deflocal *method-definition-forms* '(progn))
  33.   (deflocal *method-installation-forms* '(progn))
  34.  
  35.   (defmacro do-class-allocation ()
  36.     *class-allocation-forms*)
  37.  
  38.   (defmacro do-slot-accessors-definition ()
  39.     *slot-accessor-forms*)
  40.  
  41.   (defmacro do-set-hierarchy ()
  42.     `(initialize-hierarchy ,*class-set-hierarchy-forms*))
  43.  
  44.   (defmacro do-slot-description-allocation ()
  45.     (print `(initialize-slots ,*slot-description-forms*)))
  46.  
  47.   (defmacro do-method-definitions ()
  48.     *method-definition-forms*)
  49.  
  50.   (defmacro do-method-installation ()
  51.     *method-installation-forms*)
  52.   
  53.  
  54.   (defmacro class-allocation ()
  55.     *class-allocation-forms*)
  56.  
  57.   (defmacro slot-accessors-definition ()
  58.     *slot-accessor-forms*)
  59.  
  60.   (defmacro set-hierarchy ()
  61.     `(initialize-hierarchy ,*class-set-hierarchy-forms*))
  62.  
  63.   (defmacro slot-description-allocation ()
  64.     (print `(initialize-slots ,*slot-description-forms*)))
  65.  
  66.   (defmacro method-definitions ()
  67.     *method-definition-forms*)
  68.  
  69.   (defmacro method-installation ()
  70.     *method-installation-forms*)
  71.   
  72.     
  73.   (export do-class-allocation do-slot-accessors-definition do-set-hierarchy 
  74.       do-slot-description-allocation do-method-definitions do-method-installation
  75.       class-allocation slot-accessors-definition set-hierarchy slot-description-allocation
  76.       method-definitions method-installation)
  77.  
  78.   (defmacro reset-classes ()
  79.     (setq *class-allocation-forms* '(progn))
  80.     (setq *slot-accessor-forms* '(progn))
  81.     (setq *class-set-hierarchy-forms* '(list))
  82.     (setq *slot-description-forms* '(list))
  83.     (setq *method-definition-forms* '(progn))
  84.     (setq *method-installation-forms* '(progn))
  85.     nil)
  86.   
  87.   (export reset-classes)
  88.  
  89.   ;; helper macro
  90.   (defmacro def-exported-constant (name . rest)
  91.     `(progn (defconstant ,name ,@rest)
  92.         (export ,name)))
  93.   
  94.   (export def-exported-constant)
  95.  
  96.   (defmacro define-prim-class (class supers  slot-description-list . initargs)
  97.     (let ((slot-description-list (mapcar (lambda (x) (append (list 'owner-class class)
  98.                                  (cons 'name x)))
  99.                      slot-description-list)))
  100.       ((setter class-slots) class slot-description-list)
  101.       ((setter class-supers) class supers)
  102.       (nconc *class-allocation-forms*
  103.          (allocation-forms class initargs))
  104.       (nconc *slot-accessor-forms* 
  105.          (mapcar make-prim-slot-accessors slot-description-list))
  106.       (nconc *class-set-hierarchy-forms*
  107.          (hierarchy-forms class supers initargs))
  108.       (nconc *slot-description-forms* 
  109.          (slot-description-forms class slot-description-list initargs))
  110.       nil))
  111.  
  112.   (export define-prim-class)
  113.  
  114.   (defun make-prim-slot-accessors (slot-desc)
  115.       (let ((position (scan-args 'position slot-desc nil))
  116.         (reader (scan-args 'reader slot-desc nil))
  117.         (writer (scan-args 'writer slot-desc nil))
  118.         (accessor (scan-args 'accessor slot-desc nil)))
  119.     (when (null position)
  120.           (error "Position not defined." clock-tick))
  121.     `(progn ,(if (null reader) nil
  122.            `(def-exported-constant ,reader 
  123.               (primitive-reader ,position)))
  124.         ,(if (null writer) nil
  125.            `(def-exported-constant ,writer
  126.               (primitive-writer ,position)))
  127.         ,(if (null accessor) nil
  128.            `(progn (def-exported-constant ,accessor 
  129.                  (primitive-reader ,position))
  130.                ((bf-setter bf-setter) ,accessor
  131.                 (primitive-writer ,position))))
  132.         )))
  133.  
  134.   ;; make a class....
  135.   (defun allocation-forms (class initargs)
  136.     (if (scan-args 'allocate initargs nil)
  137.     (let ((meta (scan-args 'metaclass initargs 'class)))
  138.       `((defconstant ,class (allocate-object class)) ;; get this right later
  139.         (set-type ,class class-type)
  140.         (export ,class)))
  141.       (list `(export ,class))))
  142.  
  143.   '(defun hierarchy-forms (class supers initargs)
  144.      (let ((cpl (if (null supers) `(list ,class)
  145.           `(cons ,class 
  146.              (%class-precedence-list ,(car supers)))))
  147.        (subs (if (null supers)
  148.              nil
  149.            `((bf-setter %class-subclasses) ,(car supers)
  150.              (cons ,class (%class-subclasses ,(car supers)))))))
  151.        `((generic_generic_prin\,Object "Defining: " (standard-error-stream))
  152.      (generic_generic_prin\,Object ',class (standard-error-stream))
  153.      ((bf-setter %class-precedence-list) ,class ,cpl)
  154.      (generic_generic_prin\,Object "CPL\n" (standard-error-stream))
  155.      ((bf-setter %class-subclasses) ,class nil)
  156.      (generic_generic_prin\,Object "Sub-set" (standard-error-stream))
  157.      ((bf-setter %class-superclasses) ,class (list ,@supers))
  158.      ,subs
  159.      ((bf-setter %class-name) ,class ',class)
  160.      ((bf-setter %class-initargs) ,class ,(scan-args 'class-initargs initargs nil))
  161.      (set-class-of ,class ,(scan-args 'metaclass initargs 'class))
  162.      ((bf-setter %class-instance-size) ,class ,(calculate-slot-count class)))))
  163.   
  164.   (defun hierarchy-forms (class supers initargs)
  165.     `((list ,class
  166.        ,(if (null supers) nil `(list ,@supers))
  167.        ,(scan-args 'metaclass initargs 'class)
  168.        ',class
  169.        ',(scan-args 'direct-initargs initargs nil)
  170.        ,(calculate-slot-count class))))
  171.  
  172.   (defun calculate-slot-count (class)
  173.     (let ((supers (class-supers class)))
  174.       (if (null (class-supers class))
  175.       (list-length (class-slots class))
  176.     (+ (list-length (class-slots class))
  177.        ;; single inheritance, right?
  178.        (calculate-slot-count (car (class-supers class)))))))
  179.  
  180.   '(defun slot-description-forms (class slots initargs)
  181.     (labels ((make-slot-description (slot-desc)
  182.          `(let ((slot (allocate-object ,(or (scan-args 'class slot-desc nil)
  183.                         'local-slot-description))))
  184.         (generic_generic_prin\,Object ',slot-desc (standard-error-stream))
  185.         (fill-slot-description slot ',slot-desc))))
  186.         (let ((slot-list (mapcar make-slot-description slots)))
  187.           (format t "slots: ~a~%" slot-list)
  188.           `((generic_generic_prin\,Object ,class (standard-error-stream))
  189.         (let ((lst (list ,@slot-list)))
  190.           ((bf-setter %class-slot-list) ,class 
  191.            (nconc lst (if (null (%class-superclasses ,class)) nil
  192.                 (%class-slot-list (car (%class-superclasses ,class))))))
  193.           )))))
  194.  
  195.   ;; NB No support for default initargs...
  196.   (defun slot-description-forms (class slots initargs) 
  197.     (print slots)
  198.     (list (list 'list class
  199.         (cons 'list (mapcar (lambda (slotd)
  200.                       `(list ,(or (scan-args 'class slotd nil) 'local-slot-description)
  201.                          ',slotd))
  202.                     slots)))))
  203.              
  204.   (defmacro define-generic (name argtype)
  205.     `(progn (def-exported-constant ,name (allocate-object generic-function))
  206.         ((bf-setter %generic-discriminator) ,name (default-compute-discriminating-function ,name))
  207.         ((bf-setter %generic-name) ,name ',name)
  208.         ((bf-setter %generic-argtype) ,name ,argtype)
  209.         ))
  210.  
  211.   (export define-generic)
  212.   
  213.   (defun method-extra-args ()
  214.     (if (compile-time-p)
  215.     ()
  216.       (list '***method-status-handle*** '***method-args-handle***)))
  217.  
  218.   (defmacro method-lambda (args . junk)
  219.      `(lambda ,(append (method-extra-args) args) ,@junk))
  220.         
  221.   ;; primitive readers and writers 
  222.   ;;  (compile-time 
  223.   (progn (defmacro primitive-reader (pos)
  224.        (if (compile-time-p)
  225.            (if (< pos 10)
  226.            (make-symbol (format nil "reader-~a" pos))
  227.          `(compile-inline 1 (slot-ref ,pos)))
  228.          (lambda (x) 0)))
  229.      (defmacro primitive-writer (pos)
  230.        (if (compile-time-p) 
  231.            (if (< pos 10)
  232.            (make-symbol (format nil "writer-~a" pos))
  233.          `(compile-inline 2 (set-slot ,pos)))
  234.          (lambda (x) 0)))
  235.      )
  236. ;;   )
  237. ;;  (interpret-time 
  238. ;;   (progn (defmacro primitive-reader (pos)
  239. ;;        `(lambda (x) 
  240. ;;           (slot-value-using-class class x ,pos)))
  241. ;;      (defmacro primitive-writer (pos)
  242. ;;        `(lambda (x val)
  243. ;;           ((setter slot-value-using-class) class x ,pos val)))))
  244.   
  245.   (export method-lambda primitive-writer primitive-reader)
  246.  
  247.   (defmacro system-name (name)
  248.     (make-symbol (format nil "%_*~a*_%" name)))
  249.  
  250.   (defmacro quote-system-name (name)
  251.     (list 'quote (make-symbol (format nil "%_*~a*_%" name))))
  252.  
  253.   (export system-name quote-system-name)
  254.  
  255.   
  256.   ;; end module
  257.   )
  258.